home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / BROWSE.LSP < prev    next >
Encoding:
Text File  |  1980-01-01  |  3.1 KB  |  122 lines
  1. ; BROWSE
  2. ; Benchmark to create and browse through an AI-like data base of units
  3.  
  4. (defvar rand 21.)
  5.  
  6. #-GCLisp
  7. (defmacro char1 (x) `(aref (symbol-name ,x) 0))
  8.  
  9. #+GCLisp ; Hack, hack.  Don't cons up strings to get first char!
  10. (defmacro char1 (x)
  11.   `(multiple-value-bind (.off. .seg.) (sys::%pointer ,x)
  12.      (sys::%contents .seg. (+& .off. 21))))
  13.  
  14. (defun init (n m npats ipats)
  15.   (let ((ipats (copy-tree ipats)))
  16.     (do ((p ipats (cdr p)))
  17.     ((null (cdr p)) (rplacd p ipats)))
  18.     (do ((n n (1- n))
  19.      (i m (cond ((= i 0) m)
  20.             (t (1- i))))
  21.      (name (gensym) (gensym))
  22.      (a ()))
  23.     ((= n 0) a)
  24.       (push name a)
  25.       (do ((i i (1- i)))
  26.       ((= i 0))
  27.     (setf (get name (gensym)) ()))
  28.       (setf (get name 'pattern)
  29.         (do ((i npats (1- i))
  30.          (ipats ipats (cdr ipats))
  31.          (a ()))
  32.         ((= i 0) a)
  33.           (push (car ipats) a)))
  34.       (do ((j (- m i) (1- j)))
  35.       ((= j 0))
  36.     (setf (get name (gensym) ) ())))))
  37.  
  38. (defun browse-random () (setq rand (mod (* rand 17.) 251.)))
  39.  
  40. (defun randomize (l)
  41.   (do ((a ()))
  42.       ((null l) a)
  43.     (let ((n (mod (browse-random) (length l))))
  44.       (cond ((= n 0)
  45.          (push (car l) a)
  46.          (setq l (cdr l)))
  47.         (t
  48.          (do ((n n (1- n))
  49.           (x l (cdr x)))
  50.          ((= n 1)
  51.           (push (cadr x) a)
  52.           (rplacd x (cddr x)))))))))
  53.  
  54. (defun match (pat dat alist)
  55.   (cond ((null pat)
  56.      (null dat))
  57.     ((null dat) ())
  58.     ((or (eq (car pat) '?)            ;
  59.          (eq (car pat)
  60.          (car dat)))
  61.      (match (cdr pat) (cdr dat) alist))
  62.     ((eq (car pat) '*)
  63.      (or (match (cdr pat) dat alist)
  64.          (match (cdr pat) (cdr dat) alist)
  65.          (match pat (cdr dat) alist)))
  66.     (t (cond ((atom (car pat))
  67.           (cond ((eq (char1 (car pat)) #\?)    ; long story
  68.              (let ((val (assoc (car pat) alist)))
  69.                (cond (val (match (cons (cdr val)
  70.                            (cdr pat))
  71.                          dat alist))
  72.                  (t (match (cdr pat)
  73.                        (cdr dat)
  74.                        (cons (cons (car pat)
  75.                                (car dat))
  76.                          alist))))))
  77.             ((eq (char1 (car pat)) #\*)
  78.              (let ((val (assoc (car pat) alist)))
  79.                (cond (val (match (append (cdr val)
  80.                              (cdr pat))
  81.                          dat alist))
  82.                  (t
  83.                   (do ((l () (nconc l (list (car d))))
  84.                        (e (cons () dat) (cdr e))
  85.                        (d dat (cdr d)))
  86.                       ((null e) ())
  87.                     (cond ((match (cdr pat) d
  88.                           (cons (cons (car pat) l)
  89.                             alist))
  90.                        (return t))))))))))
  91.          (t (and
  92.               (not (atom (car dat)))
  93.               (match (car pat)
  94.                  (car dat) alist)
  95.               (match (cdr pat)
  96.                  (cdr dat) alist)))))))
  97.  
  98. (defun browse ()
  99.   (setf rand 21)
  100.   (investigate (randomize
  101.          (init 100. 10. 4. '((a a a b b b b a a a a a b b a a a)
  102.                      (a a b b b b a a
  103.                     (a a)(b b))
  104.                      (a a a b (b a) b a b a))))
  105.            '((*a ?b *b ?b a *a a *b *a)
  106.          (*a *b *b *a (*a) (*b))
  107.          (? ? * (b a) * ? ?))))
  108.  
  109. (defun investigate (units pats)
  110.   (do ((units units (cdr units)))
  111.       ((null units))
  112.     (do ((pats pats (cdr pats)))
  113.     ((null pats))
  114.       (do ((p (get (car units) 'pattern)
  115.           (cdr p)))
  116.       ((null p))
  117.     (match (car pats) (car p) ())))))
  118.  
  119. (define-timer browse "Browse" (browse))
  120.  
  121. (qa-attempt "Browse" (browse) nil)
  122.